home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / soundex.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  83 lines
  1. ;"soundex.scm" Original SOUNDEX algorithm.
  2. ;From jjb@isye.gatech.edu Mon May  2 22:29:43 1994
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ;Date: Mon, 2 May 94 13:45:39 -0500
  7.  
  8. ; Taken from Knuth, Vol. 3 "Sorting and searching", pp 391--2
  9.  
  10. (require 'common-list-functions)
  11.  
  12. (define SOUNDEX
  13.   (let* ((letters-to-omit
  14.            (list #\A #\E #\H #\I #\O #\U #\W #\Y))
  15.          (codes
  16.           (list (list #\B #\1)
  17.                 (list #\F #\1)
  18.                 (list #\P #\1)
  19.                 (list #\V #\1)
  20.                 ;
  21.                 (list #\C #\2)
  22.                 (list #\G #\2)
  23.                 (list #\J #\2)
  24.                 (list #\K #\2)
  25.                 (list #\Q #\2)
  26.                 (list #\S #\2)
  27.                 (list #\X #\2)
  28.                 (list #\Z #\2)
  29.                 ;
  30.                 (list #\D #\3)
  31.                 (list #\T #\3)
  32.                 ;
  33.                 (list #\L #\4)
  34.                 ;
  35.                 (list #\M #\5)
  36.                 (list #\N #\5)
  37.                 ;
  38.                 (list #\R #\6)))
  39.          (xform
  40.           (lambda (c)
  41.             (let ((code (assq c codes)))
  42.               (if code
  43.                   (cadr code)
  44.                   c)))))
  45.     (lambda (name)
  46.       (let ((char-list
  47.              (map char-upcase
  48.                   (remove-if (lambda (c)
  49.                                (not (char-alphabetic? c)))
  50.                              (string->list name)))))
  51.         (if (null? char-list)
  52.             name
  53.             (let* (; Replace letters except first with codes:
  54.                    (n1 (cons (car char-list) (map xform char-list)))
  55.                    ; If 2 or more letter with same code are adjacent
  56.                    ; in the original name, omit all but the first:
  57.                    (n2 (let loop ((chars n1))
  58.                          (cond ((null? (cdr chars))
  59.                                 chars)
  60.                                (else
  61.                                 (if (char=? (xform (car chars))
  62.                                             (cadr chars))
  63.                                     (loop (cdr chars))
  64.                                     (cons (car chars) (loop (cdr chars))))))))
  65.                    ; Omit vowels and similar letters, except first:
  66.                    (n3 (cons (car char-list)
  67.                              (remove-if
  68.                               (lambda (c)
  69.                                 (memq c letters-to-omit))
  70.                               (cdr n2)))))
  71.               ;
  72.               ; pad with 0's or drop rightmost digits until of form "annn":
  73.               (let loop ((rev-chars (reverse n3)))
  74.                 (let ((len (length rev-chars)))
  75.                   (cond ((= 4 len)
  76.                          (list->string (reverse rev-chars)))
  77.                         ((> 4 len)
  78.                          (loop (cons #\0 rev-chars)))
  79.                         ((< 4 len)
  80.                          (loop (cdr rev-chars))))))))))))
  81.  
  82.  
  83.